home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xlmath.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  9.9 KB  |  447 lines
  1. /* xlmath - xlisp built-in arithmetic functions */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7. #include <math.h>
  8.  
  9. /* external variables */
  10. extern LVAL true;
  11.  
  12. /* forward local declarations */
  13. #ifdef ANSI
  14. LVAL unary(int fcn);
  15. LVAL binary(int fcn);
  16. LVAL predicate(int fcn);
  17. LVAL compare(int fcn);
  18. void checkizero(FIXTYPE iarg);
  19. void checkfzero(FLOTYPE farg);
  20. void checkfneg(FLOTYPE farg);
  21. void badiop(void);
  22. void badfop(void);
  23. #else
  24. FORWARD LVAL unary();
  25. FORWARD LVAL binary();
  26. FORWARD LVAL predicate();
  27. FORWARD LVAL compare();
  28. FORWARD VOID checkizero();
  29. FORWARD VOID checkfzero();
  30. FORWARD VOID checkfneg();
  31. FORWARD VOID badiop();
  32. FORWARD VOID badfop();
  33. #endif
  34.  
  35. /* binary functions */
  36. LVAL xadd()       { return (binary('+')); } /* + */
  37. LVAL xsub()       { return (binary('-')); } /* - */
  38. LVAL xmul()       { return (binary('*')); } /* * */
  39. LVAL xdiv()       { return (binary('/')); } /* / */
  40. LVAL xrem()       { return (binary('%')); } /* rem */
  41. LVAL xmin()       { return (binary('m')); } /* min */
  42. LVAL xmax()       { return (binary('M')); } /* max */
  43. LVAL xexpt()   { return (binary('E')); } /* expt */
  44. LVAL xlogand() { return (binary('&')); } /* logand */
  45. LVAL xlogior() { return (binary('|')); } /* logior */
  46. LVAL xlogxor() { return (binary('^')); } /* logxor */
  47.  
  48. /* xgcd - greatest common divisor */
  49. LVAL xgcd()
  50. {
  51.     FIXTYPE m,n,r;
  52.     LVAL arg;
  53.  
  54.     if (!moreargs())                    /* check for identity case */
  55.         return (cvfixnum((FIXTYPE)0));
  56.     arg = xlgafixnum();
  57.     n = getfixnum(arg);
  58.     if (n < (FIXTYPE)0) n = -n;            /* absolute value */
  59.     while (moreargs()) {
  60.         arg = xlgafixnum();
  61.         m = getfixnum(arg);
  62.         if (m < (FIXTYPE)0) m = -m;        /* absolute value */
  63.         for (;;) {                        /* euclid's algorithm */
  64.             r = m % n;
  65.             if (r == (FIXTYPE)0)
  66.                 break;
  67.             m = n;
  68.             n = r;
  69.         }
  70.     }
  71.     return (cvfixnum(n));
  72. }
  73.  
  74. /* binary - handle binary operations */
  75. LOCAL LVAL binary(fcn)
  76.   int fcn;
  77. {
  78.     FIXTYPE ival,iarg;
  79.     FLOTYPE fval,farg;
  80.     LVAL arg;
  81.     int mode;
  82.  
  83.     /* get the first argument */
  84.     arg = xlgetarg();
  85.  
  86.     /* set the type of the first argument */
  87.     if (fixp(arg)) {
  88.         ival = getfixnum(arg);
  89.         mode = 'I';
  90.     }
  91.     else if (floatp(arg)) {
  92.         fval = getflonum(arg);
  93.         mode = 'F';
  94.     }
  95.     else
  96.                 xlbadtype(arg);
  97.  
  98.     /* treat a single argument as a special case */
  99.     if (!moreargs()) {
  100.         switch (fcn) {
  101.         case '-':
  102.             switch (mode) {
  103.             case 'I':
  104.                 ival = -ival;
  105.                 break;
  106.             case 'F':
  107.                 fval = -fval;
  108.                 break;
  109.             }
  110.             break;
  111.         case '/':
  112.             switch (mode) {
  113.             case 'I':
  114.                 checkizero(ival);
  115.                 ival = 1 / ival;
  116.                 break;
  117.             case 'F':
  118.                 checkfzero(fval);
  119.                 fval = 1.0 / fval;
  120.                 break;
  121.             }
  122.         }
  123.     }
  124.  
  125.     /* handle each remaining argument */
  126.     while (moreargs()) {
  127.  
  128.         /* get the next argument */
  129.         arg = xlgetarg();
  130.  
  131.         /* check its type */
  132.         if (fixp(arg)) {
  133.             switch (mode) {
  134.             case 'I':
  135.                 iarg = getfixnum(arg);
  136.                 break;
  137.             case 'F':
  138.                 farg = (FLOTYPE)getfixnum(arg);
  139.                 break;
  140.             }
  141.         }
  142.         else if (floatp(arg)) {
  143.             switch (mode) {
  144.             case 'I':
  145.                 fval = (FLOTYPE)ival;
  146.                 farg = getflonum(arg);
  147.                 mode = 'F';
  148.                 break;
  149.             case 'F':
  150.                 farg = getflonum(arg);
  151.                 break;
  152.             }
  153.         }
  154.         else
  155.             xlbadtype(arg);
  156.  
  157.         /* accumulate the result value */
  158.         switch (mode) {
  159.         case 'I':
  160.             switch (fcn) {
  161.             case '+':    ival += iarg; break;
  162.             case '-':    ival -= iarg; break;
  163.             case '*':    ival *= iarg; break;
  164.             case '/':    checkizero(iarg); ival /= iarg; break;
  165.             case '%':    checkizero(iarg); ival %= iarg; break;
  166.             case 'M':    if (iarg > ival) ival = iarg; break;
  167.             case 'm':    if (iarg < ival) ival = iarg; break;
  168.             case '&':    ival &= iarg; break;
  169.             case '|':    ival |= iarg; break;
  170.             case '^':    ival ^= iarg; break;
  171.             default:    badiop();
  172.             }
  173.             break;
  174.         case 'F':
  175.             switch (fcn) {
  176.             case '+':    fval += farg; break;
  177.             case '-':    fval -= farg; break;
  178.             case '*':    fval *= farg; break;
  179.             case '/':    checkfzero(farg); fval /= farg; break;
  180.             case 'M':    if (farg > fval) fval = farg; break;
  181.             case 'm':    if (farg < fval) fval = farg; break;
  182.             case 'E':    fval = pow(fval,farg); break;
  183.             default:    badfop();
  184.             }
  185.             break;
  186.         }
  187.     }
  188.  
  189.     /* return the result */
  190.     if (mode=='I') 
  191.         return (cvfixnum(ival));
  192.     else
  193.         return (cvflonum(fval));
  194. }
  195.  
  196. /* checkizero - check for integer division by zero */
  197. VOID checkizero(iarg)
  198.   FIXTYPE iarg;
  199. {
  200.     if (iarg == 0)
  201.         xlfail("division by zero");
  202. }
  203.  
  204. /* checkfzero - check for floating point division by zero */
  205. VOID checkfzero(farg)
  206.   FLOTYPE farg;
  207. {
  208.     if (farg == 0.0)
  209.         xlfail("division by zero");
  210. }
  211.  
  212. /* checkfneg - check for square root of a negative number */
  213. VOID checkfneg(farg)
  214.   FLOTYPE farg;
  215. {
  216.     if (farg < 0.0)
  217.         xlfail("square root of a negative number");
  218. }
  219.  
  220. /* unary functions */
  221. LVAL xlognot() { return (unary('~')); } /* lognot */
  222. LVAL xabs()       { return (unary('A')); } /* abs */
  223. LVAL xadd1()   { return (unary('+')); } /* 1+ */
  224. LVAL xsub1()   { return (unary('-')); } /* 1- */
  225. LVAL xsin()       { return (unary('S')); } /* sin */
  226. LVAL xcos()       { return (unary('C')); } /* cos */
  227. LVAL xtan()       { return (unary('T')); } /* tan */
  228. #ifdef STRUCTS /* asin, acos, and atan are xlisp2.1 functions */
  229. LVAL xasin()   { return (unary('s')); } /* asin */
  230. LVAL xacos()   { return (unary('c')); } /* acos */
  231. LVAL xatan()   { return (unary('t')); } /* atan */
  232. #endif
  233. LVAL xexp()       { return (unary('E')); } /* exp */
  234. LVAL xsqrt()   { return (unary('R')); } /* sqrt */
  235. LVAL xfix()       { return (unary('I')); } /* truncate */
  236. LVAL xfloat()  { return (unary('F')); } /* float */
  237. LVAL xrand()   { return (unary('?')); } /* random */
  238.  
  239. /* unary - handle unary operations */
  240. LOCAL LVAL unary(fcn)
  241.   int fcn;
  242. {
  243.     FLOTYPE fval;
  244.     FIXTYPE ival;
  245.     LVAL arg;
  246.  
  247.     /* get the argument */
  248.     arg = xlgetarg();
  249.     xllastarg();
  250.  
  251.     /* check its type */
  252.     if (fixp(arg)) {
  253.         ival = getfixnum(arg);
  254.         switch (fcn) {
  255.         case '~':        ival = ~ival; break;
  256.         case 'A':        ival = (ival < 0 ? -ival : ival); break;
  257.         case '+':        ival++; break;
  258.         case '-':        ival--; break;
  259.         case 'I':        break;
  260.         case 'F':        return (cvflonum((FLOTYPE)ival));
  261.         case '?':        ival = (FIXTYPE)osrand((int)ival); break;
  262.         default:        badiop();
  263.         }
  264.         return (cvfixnum(ival));
  265.     }
  266.     else if (floatp(arg)) {
  267.         fval = getflonum(arg);
  268.         switch (fcn) {
  269.         case 'A':        fval = (fval < 0.0 ? -fval : fval); break;
  270.         case '+':        fval += 1.0; break;
  271.         case '-':        fval -= 1.0; break;
  272.         case 'S':        fval = sin(fval); break;
  273.         case 'C':        fval = cos(fval); break;
  274.         case 'T':        fval = tan(fval); break;
  275. #ifdef STRUCTS
  276.         case 's':        fval = asin(fval); break;
  277.         case 'c':        fval = acos(fval); break;
  278.         case 't':        fval = atan(fval); break;
  279. #endif
  280.         case 'E':        fval = exp(fval); break;
  281.         case 'R':        checkfneg(fval); fval = sqrt(fval); break;
  282.         case 'I':        return (cvfixnum((FIXTYPE)fval));
  283.         case 'F':        break;
  284.         default:        badfop();
  285.         }
  286.         return (cvflonum(fval));
  287.     }
  288.     else {
  289.         xlbadtype(arg);
  290.         return (NIL);    /* fake out compiler warning */
  291.     }
  292. }
  293.  
  294. /* unary predicates */
  295. LVAL xminusp() { return (predicate('-')); } /* minusp */
  296. LVAL xzerop()  { return (predicate('Z')); } /* zerop */
  297. LVAL xplusp()  { return (predicate('+')); } /* plusp */
  298. LVAL xevenp()  { return (predicate('E')); } /* evenp */
  299. LVAL xoddp()   { return (predicate('O')); } /* oddp */
  300.  
  301. /* predicate - handle a predicate function */
  302. LOCAL LVAL predicate(fcn)
  303.   int fcn;
  304. {
  305.     FLOTYPE fval;
  306.     FIXTYPE ival;
  307.     LVAL arg;
  308.  
  309.     /* get the argument */
  310.     arg = xlgetarg();
  311.     xllastarg();
  312.  
  313.     /* check the argument type */
  314.     if (fixp(arg)) {
  315.         ival = getfixnum(arg);
  316.         switch (fcn) {
  317.         case '-':        ival = (ival < 0); break;
  318.         case 'Z':        ival = (ival == 0); break;
  319.         case '+':        ival = (ival > 0); break;
  320.         case 'E':        ival = ((ival & 1) == 0); break;
  321.         case 'O':        ival = ((ival & 1) != 0); break;
  322.         default:        badiop();
  323.         }
  324.     }
  325.     else if (floatp(arg)) {
  326.         fval = getflonum(arg);
  327.         switch (fcn) {
  328.         case '-':        ival = (fval < 0); break;
  329.         case 'Z':        ival = (fval == 0); break;
  330.         case '+':        ival = (fval > 0); break;
  331.         default:        badfop();
  332.         }
  333.     }
  334.     else
  335.         xlbadtype(arg);
  336.  
  337.     /* return the result value */
  338.     return (ival ? true : NIL);
  339. }
  340.  
  341. /* comparison functions */
  342. LVAL xlss() { return (compare('<')); } /* < */
  343. LVAL xleq() { return (compare('L')); } /* <= */
  344. LVAL xequ() { return (compare('=')); } /* = */
  345. LVAL xneq() { return (compare('#')); } /* /= */
  346. LVAL xgeq() { return (compare('G')); } /* >= */
  347. LVAL xgtr() { return (compare('>')); } /* > */
  348.  
  349. /* compare - common compare function */
  350. LOCAL LVAL compare(fcn)
  351.   int fcn;
  352. {
  353.     FIXTYPE icmp,ival,iarg;
  354.     FLOTYPE fcmp,fval,farg;
  355.     LVAL arg;
  356.     int mode;
  357.  
  358.     /* get the first argument */
  359.     arg = xlgetarg();
  360.  
  361.     /* set the type of the first argument */
  362.     if (fixp(arg)) {
  363.         ival = getfixnum(arg);
  364.         mode = 'I';
  365.     }
  366.     else if (floatp(arg)) {
  367.         fval = getflonum(arg);
  368.         mode = 'F';
  369.     }
  370.     else
  371.         xlbadtype(arg);
  372.  
  373.     /* handle each remaining argument */
  374.     for (icmp = TRUE; icmp && moreargs(); ival = iarg, fval = farg) {
  375.  
  376.         /* get the next argument */
  377.         arg = xlgetarg();
  378.  
  379.         /* check its type */
  380.         if (fixp(arg)) {
  381.             switch (mode) {
  382.             case 'I':
  383.                 iarg = getfixnum(arg);
  384.                 break;
  385.             case 'F':
  386.                 farg = (FLOTYPE)getfixnum(arg);
  387.                 break;
  388.             }
  389.         }
  390.         else if (floatp(arg)) {
  391.             switch (mode) {
  392.             case 'I':
  393.                 fval = (FLOTYPE)ival;
  394.                 farg = getflonum(arg);
  395.                 mode = 'F';
  396.                 break;
  397.             case 'F':
  398.                 farg = getflonum(arg);
  399.                 break;
  400.             }
  401.         }
  402.         else
  403.             xlbadtype(arg);
  404.  
  405.         /* compute result of the compare */
  406.         switch (mode) {
  407.         case 'I':
  408.             icmp = ival - iarg;
  409.             switch (fcn) {
  410.             case '<':    icmp = (icmp < 0); break;
  411.             case 'L':    icmp = (icmp <= 0); break;
  412.             case '=':    icmp = (icmp == 0); break;
  413.             case '#':    icmp = (icmp != 0); break;
  414.             case 'G':    icmp = (icmp >= 0); break;
  415.             case '>':    icmp = (icmp > 0); break;
  416.             }
  417.             break;
  418.         case 'F':
  419.             fcmp = fval - farg;
  420.             switch (fcn) {
  421.             case '<':    icmp = (fcmp < 0.0); break;
  422.             case 'L':    icmp = (fcmp <= 0.0); break;
  423.             case '=':    icmp = (fcmp == 0.0); break;
  424.             case '#':    icmp = (fcmp != 0.0); break;
  425.             case 'G':    icmp = (fcmp >= 0.0); break;
  426.             case '>':    icmp = (fcmp > 0.0); break;
  427.             }
  428.             break;
  429.         }
  430.     }
  431.  
  432.     /* return the result */
  433.     return (icmp ? true : NIL);
  434. }
  435.  
  436. /* badiop - bad integer operation */
  437. LOCAL VOID badiop()
  438. {
  439.     xlfail("bad integer operation");
  440. }
  441.  
  442. /* badfop - bad floating point operation */
  443. LOCAL VOID badfop()
  444. {
  445.     xlfail("bad floating point operation");
  446. }
  447.